home *** CD-ROM | disk | FTP | other *** search
/ Sound Fx / Sound Fx.iso / Software / ZIPED / DWSTKW.EXE / VB / VB4 / PLAY16 / PLAYSTK.BAS next >
Encoding:
BASIC Source File  |  1996-07-08  |  8.1 KB  |  284 lines
  1. '******************************************************************************
  2. ' File:      playstk.c
  3. ' Version:   1.00
  4. ' Tab stops: every 2 columns
  5. ' Project:   DiamondWare's Sound ToolKit for Windows
  6. ' Copyright: 1996 DiamondWare, Ltd.  All rights reserved.*
  7. ' Written:   95/12/11 by David Alen
  8. ' Purpose:   Contains sample application using the WIN-STK
  9. ' History:   96/03/28 KW & JCL finalized for 1.0
  10. '            06/04/14 JCL finalized for 1.01
  11. '            06/05/13 JCL finalized for 1.1 (no changes)
  12. '            06/05/27 JCL finalized for 1.11 (no changes)
  13. '            06/07/08 JCL finalized for 1.2 (no changes)
  14. '
  15. '*Permission is expressely granted to use this program or any derivitive made
  16. ' from it to registered users of the WIN-STK.
  17. '******************************************************************************
  18.  
  19.  
  20.  
  21. Attribute VB_Name = "PLAYSTK"
  22. Option Explicit
  23.  
  24. Type OFSTRUCT
  25.     cBytes As String * 1
  26.     fFixedDisk As String * 1
  27.     nErrCode As Integer
  28.     reserved As String * 4
  29.     szPathName As String * 128
  30. End Type
  31.  
  32. Declare Function GlobalAlloc Lib "Kernel" (ByVal wFlags As Integer, ByVal dwBytes As Long) As Integer
  33. Declare Function GlobalFree Lib "Kernel" (ByVal hMem As Integer) As Integer
  34. Declare Function GlobalLock Lib "Kernel" (ByVal hMem As Integer) As Long
  35. Declare Function GlobalUnlock Lib "Kernel" (ByVal hMem As Integer) As Integer
  36.  
  37. Declare Function OpenFile Lib "Kernel" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Integer) As Integer
  38. Declare Function llseek Lib "Kernel" Alias "_llseek" (ByVal hfile As Integer, ByVal lOffset As Long, ByVal iOrigin As Integer) As Long
  39. Declare Function hRead Lib "Kernel" Alias "_hread" (ByVal hfile As Integer, ByVal lOffset As Long, ByVal iSize As Long) As Long
  40. Declare Function lclose Lib "Kernel" Alias "_lclose" (ByVal hfile As Integer) As Integer
  41.  
  42. Global Const OF_READ = &H0
  43.  
  44. Global Const GENERIC_READ = &H80000000
  45. Global Const FILE_SHARE_READ = &H1
  46. Global Const OPEN_EXISTING = 3
  47. Global Const FILE_ATTRIBUTE_NORMAL = &H80
  48. Global Const GMEM_MOVEABLE = &H2
  49. Global Const GMEM_SHARE = &H2000
  50.  
  51. Global Const CD_ACTION_OPEN = 1
  52.  
  53. Global Const dws_NOSUCCESS = 0
  54.  
  55. Type SoundInfo
  56.     FileName As String
  57.     Handle As Long
  58.     UnlockHandle As Integer
  59.     soundnum As Integer
  60.     Rate As Integer
  61. End Type
  62.  
  63. Global t_dws_DR As dws_DETECTRESULTS
  64. Global t_dws_ID As dws_IDEAL
  65. Global t_dws_DP As dws_DPlay
  66. Global t_dws_MP As dws_MPlay
  67.  
  68. Global giNumSounds As Integer
  69. Global gtSI() As SoundInfo
  70. Global gPlay As dws_DPlay
  71.  
  72. Function dwsLoadWave(psFileName As String) As Integer
  73.     ' This procedure loads the passed WAVE file and
  74.     ' prepares it for use with the WinSTK.  It returns the INDEX of gtSI()
  75.     ' that the wave was loaded into.
  76.  
  77.     On Error GoTo LWE
  78.  
  79.     Dim WaveDWD As Long
  80.     Dim hWaveDWD As Long
  81.     Dim WaveTmp As Long
  82.     Dim hWaveTmp As Long
  83.     Dim iStatus As Integer
  84.     Dim lLen As Long
  85.     Dim lTemp As Long
  86.     Dim hfile As Long
  87.     Dim iLoop As Integer
  88.     Dim iIndex As Integer
  89.     
  90.     Dim iResult As Integer
  91.     
  92.     Dim openbuff As OFSTRUCT
  93.     
  94.     hfile = OpenFile(psFileName, openbuff, OF_READ)
  95.     
  96.     If hfile > 0 Then
  97.         lLen = llseek(hfile, 0&, 2)
  98.  
  99.         hWaveTmp = GlobalAlloc(GMEM_MOVEABLE Or GMEM_SHARE, lLen)
  100.         WaveTmp = GlobalLock(hWaveTmp)
  101.  
  102.         iResult = llseek(hfile, 0&, 0)
  103.         iResult = hRead(hfile, WaveTmp, lLen)
  104.         iResult = lclose(hfile)
  105.     Else
  106.         Exit Function
  107.     End If
  108.     
  109.     If InStr(UCase(psFileName), ".WAV") Then
  110.     
  111.         '  convert WAV to DWD
  112.         lTemp = lLen
  113.         iStatus = dws_WAV2DWD(ByVal WaveTmp, lTemp, ByVal 0&)
  114.         If iStatus = False Then
  115.             dwsShowError
  116.             Exit Function
  117.         End If
  118.     
  119.         hWaveDWD = GlobalAlloc(GMEM_MOVEABLE, lTemp)
  120.         WaveDWD = GlobalLock(hWaveDWD)
  121.     
  122.         iStatus = dws_WAV2DWD(ByVal WaveTmp, lLen, ByVal WaveDWD)
  123.     
  124.         GlobalUnlock (hWaveTmp)
  125.         GlobalFree (hWaveTmp)
  126.     
  127.         If iStatus = False Then
  128.             GlobalUnlock (hWaveDWD)
  129.             GlobalFree (hWaveDWD)
  130.             dwsShowError
  131.             Exit Function
  132.         End If
  133.     Else
  134.         hWaveDWD = hWaveTmp
  135.         WaveDWD = WaveTmp
  136.     End If
  137.     
  138.     iIndex = -1
  139.     
  140.     giNumSounds = giNumSounds + 1
  141.     
  142.     ' Find an empty index if exists
  143.     For iLoop = 0 To UBound(gtSI)
  144.         If gtSI(iLoop).Handle = 0 Then
  145.             ' Use this one!
  146.             iIndex = iLoop
  147.             Exit For
  148.         End If
  149.     Next iLoop
  150.     
  151.     If iIndex = -1 Then
  152.         ReDim Preserve gtSI(UBound(gtSI) + 1) As SoundInfo
  153.         iIndex = UBound(gtSI)
  154.     End If
  155.     
  156.     gtSI(iIndex).FileName = psFileName
  157.     gtSI(iIndex).Handle = WaveDWD
  158.     gtSI(iIndex).UnlockHandle = hWaveDWD
  159.  
  160.     iResult = dws_DGetRateFromDWD(ByVal gtSI(iIndex).Handle, gtSI(iIndex).Rate)
  161.     
  162.     dwsLoadWave = iIndex
  163.     
  164. LWER:
  165.     Exit Function
  166.     
  167. LWE:
  168.     dwsLoadWave = -1
  169.     MsgBox "Error '" + Error + "' occurred in DWSTEST:dwsLoadWave!"
  170.     Resume LWER
  171. End Function
  172.  
  173. Function dwsPlayWave(piIndex As Integer) As Integer
  174.     ' This procedure plays a loaded wave by using the passed
  175.     ' memory handle.
  176.  
  177.     Dim tPlay As dws_DPlay
  178.     Dim iStatus As Integer
  179.  
  180.     LSet tPlay = gPlay
  181.     
  182.     tPlay.snd = gtSI(piIndex).Handle
  183.     tPlay.count = 1
  184.     
  185.     tPlay.flags = dws_dplay_SND Or dws_dplay_COUNT Or dws_dplay_LVOL Or dws_dplay_RVOL Or dws_dplay_PITCH
  186.     
  187.     iStatus = dws_DPlay(tPlay)
  188.         
  189.     gtSI(piIndex).soundnum = tPlay.soundnum
  190.     
  191.     If iStatus = 0 Then
  192.         dwsShowError
  193.         Exit Function
  194.     End If
  195.     
  196.     dwsPlayWave = True
  197. End Function
  198.  
  199. Sub dwsShowError()
  200.     ' An error has occurred!  Show it!
  201.     Dim iError As Integer
  202.     Dim sError As String
  203.     
  204.     iError = dws_ErrNo()
  205.     
  206.     Select Case iError
  207.         Case dws_NOTINITTED
  208.             sError = "Not Initialized"
  209.         Case dws_ALREADYINITTED
  210.             sError = "Already Initialized"
  211.         Case dws_NOTSUPPORTED
  212.             sError = "Not Supported"
  213.         Case dws_INTERNALERROR
  214.             sError = "Internal Error"
  215.         Case dws_INVALIDPOINTER
  216.             sError = "Invalid Pointer"
  217.         Case dws_RESOURCEINUSE
  218.             sError = "Resource In Use"
  219.         Case dws_MEMORYALLOCFAILED
  220.             sError = "Memory Alloc Failed"
  221.         Case dws_SETEVENTFAILED
  222.             sError = "Set Event Failed"
  223.         Case dws_BUSY
  224.             sError = "Busy"
  225.         Case dws_Init_BUFTOOSMALL
  226.             sError = "Buffer Too Small"
  227.         Case dws_D_NOTADWD
  228.             sError = "Not a DWD"
  229.         Case dws_D_NOTSUPPORTEDVER
  230.             sError = "Not Supported Version"
  231.         Case dws_D_BADDPLAY
  232.             sError = "Bad (D) Play"
  233.         Case dws_DPlay_NOSPACEFORSOUND
  234.             sError = "No Space For Sound"
  235.         Case dws_WAV2DWD_NOTAWAVE
  236.             sError = "Not A Wave"
  237.         Case dws_WAV2DWD_UNSUPPORTEDFORMAT
  238.             sError = "Unsupport Format"
  239.         Case dws_M_BADMPLAY
  240.             sError = "Bad (M) Play"
  241.         Case Else
  242.             sError = "<unknown #" + CStr(iError) + ">"
  243.     End Select
  244.     
  245.     MsgBox "Error '" + sError + "' occurred!"
  246. End Sub
  247.  
  248. Function dwsUnloadWave(piIndex As Integer) As Integer
  249.     ' This procedure removes a loaded WAVE file via
  250.     ' the Wave's Index.
  251.     
  252.     Dim iLoop As Integer
  253.     Dim iResult As Integer
  254.  
  255.     On Error GoTo UWE
  256.  
  257.     If giNumSounds = 0 Or piIndex < 0 Or piIndex > (giNumSounds - 1) Then
  258.         Exit Function
  259.     End If
  260.     
  261.     If gtSI(piIndex).Handle <> 0 Then
  262.         ' Free the memory that's holding the wave
  263.         iResult = GlobalUnlock(gtSI(piIndex).UnlockHandle)
  264.         iResult = GlobalFree(gtSI(piIndex).UnlockHandle)
  265.         
  266.         ' Remove the sound Index!
  267.         gtSI(piIndex).Handle = 0
  268.         gtSI(piIndex).UnlockHandle = 0
  269.         gtSI(piIndex).FileName = ""
  270.         
  271.         giNumSounds = giNumSounds - 1
  272.         
  273.         dwsUnloadWave = True
  274.     End If
  275.  
  276. UWER:
  277.     Exit Function
  278.     
  279. UWE:
  280.     MsgBox "Error '" + Error + "' occurred in DWSTEST:dwsUnloadLoadWave!"
  281.     Resume UWER
  282. End Function
  283.  
  284.